home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / AV Parser / AV Program / pict-scrap.Lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  3.0 KB  |  101 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;
  3. ;; Pict-Scrap.Lisp
  4. ;;
  5. ;;  This version works with MCL 2.0ß1p3.
  6. ;;
  7. ;;  Written by Mark Johnson, Cognitive Science, Brown University.
  8. ;;  Email: mj@cs.brown.edu
  9. ;;
  10. ;;  This file a scrap-handler for scraps of type PICT
  11. ;;
  12. ;;  Once this is installed, windows which copy and paste PICTs will
  13. ;;  be able to share their work with other applications
  14. ;;
  15.  
  16. (in-package :ccl)
  17.  
  18. (defclass pict-scrap-handler (scrap-handler) ())
  19.  
  20. (defmethod set-internal-scrap ((self pict-scrap-handler) scrap)
  21.   (declare (ignore scrap))
  22.   (let ((old-pict (get-internal-scrap self)))
  23.     (when (handlep old-pict)
  24.       (#_KillPicture old-pict)))      ;dispose of the old pict before we
  25.                                       ;put a new one in its place
  26.                                       ;this will crash if your program has
  27.                                       ;other pointers to the pict, so
  28.                                       ;always make sure cut/copy really do
  29.                                       ;-copy- the pict
  30.   (call-next-method))
  31.  
  32. (defmethod externalize-scrap ((self pict-scrap-handler))
  33.   (let ((the-pict (get-internal-scrap self)))
  34.     (when the-pict
  35.       (let ((size (#_GetHandleSize the-pict)))
  36.         (with-dereferenced-handles ((p the-pict))
  37.           (#_PutScrap size :pict p))))))
  38.  
  39. (defmethod internalize-scrap ((self pict-scrap-handler))
  40.   (let ((the-pict (#_NewHandle 0)))
  41.     (rlet ((offset :integer))
  42.       (#_GetScrap the-pict :pict offset)
  43.       (set-internal-scrap self the-pict))))
  44.  
  45. (unless (assoc :pict *scrap-handler-alist*)
  46.   (push `(:pict . ,(make-instance 'pict-scrap-handler))
  47.         *scrap-handler-alist*))
  48.  
  49. (provide :pict-scrap)
  50.  
  51. #|
  52. ;;;;;;;;;;;;;;;;;;;;;
  53. ;;
  54. ;; a simple window, supporting cut and paste with picts
  55. ;;
  56. ;; because it doesn't remember the picts which it pastes,
  57. ;; it can only cut a pseudo-pict, that is, a pict which
  58. ;; contains the window's current contents as a bitmap.
  59.  
  60.  
  61. (defclass pict-window (window) ())
  62.  
  63. (defmethod paste ((self pict-window))
  64.   (let ((pict (get-scrap :pict)))
  65.     (when pict
  66.       (with-focused-view self
  67.         (rlet ((r :rect))
  68.           (with-dereferenced-handles ((pict-point pict))
  69.             (copy-record (rref pict-point :picture.picframe
  70.                                :storage :pointer)
  71.                          :rect
  72.                          r))
  73.           (#_DrawPicture pict r))))))
  74.  
  75. (defmethod copy ((self pict-window))
  76.   (let* ((wptr (wptr self))
  77.          (rect (rref wptr :window.portrect)))
  78.     (with-focused-view self
  79.       (let* ((pict (#_OpenPicture rect))
  80.              (bits (rref wptr :window.portbits)))
  81.         (#_CopyBits bits
  82.                    bits
  83.                    rect
  84.                    rect
  85.                    0        ;transfer mode
  86.                    (%null-ptr))
  87.         (#_ClosePicture)
  88.         (put-scrap :pict pict)))))
  89.  
  90. (defmethod clear ((self pict-window))
  91.   (with-focused-view self
  92.     (#_EraseRect (rref (wptr self) :window.portrect))))
  93.  
  94. (defmethod cut ((self pict-window))
  95.   (copy)
  96.   (clear))
  97.  
  98. (make-instance 'pict-window)
  99.       
  100.  
  101. |#